home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / packing_old < prev    next >
Encoding:
Text File  |  1991-09-21  |  4.0 KB  |  189 lines
  1. \ OBSOLETE - Use new Packing Code by Marty Kees
  2. \ This is provided for those who need the old system.
  3. \
  4. \ Packing Routines needed by IFF files
  5. \
  6. \ Packs Bitmap into Run-Length-Encoded data.
  7. \ Can be used to Pack IFF data in "cmpByteRun1" form.
  8. \
  9. \ Technique:
  10. \   Normal Data is stored as a positive count followed
  11. \      by N+1 bytes of data.
  12. \   Redundant data is stored as a negative count
  13. \      followed by the byte to be repeated 1-N times.
  14. \
  15. \ Translations from 'C' by Phil Burk
  16. \
  17. \ Original By Jerry Morrison and Steve Shaw, Electronic Arts.
  18. \ Author: Phil Burk
  19. \ Copyright 1988 Phil Burk
  20. \ All Rights reserved
  21.  
  22. decimal
  23. exists? includes
  24. .IF  getmodule includes
  25. .ELSE include? bm_rows ji:graphics/gfx.j
  26. .THEN
  27. include? { ju:locals
  28.  
  29. ANEW TASK-PACKING_OLD
  30.  
  31. \ Use PAD for buffer.
  32. 0 value iffp-dst
  33. 0 value iffp-dst#
  34.  
  35. : PUTDUMP  { numbytes -- error }
  36.     numbytes 1+ iffp-dst# >
  37.     IF true
  38.     ELSE  numbytes 1- iffp-dst c!
  39.         pad iffp-dst 1+ numbytes move
  40.         iffp-dst# numbytes 1+ - -> iffp-dst#
  41.         iffp-dst numbytes 1+ + -> iffp-dst
  42.         false
  43.     THEN
  44.  
  45. ;
  46.  
  47. : PUTRUN { numbytes runchar -- error }
  48.     2 iffp-dst# >
  49.     IF true
  50.     ELSE  1 numbytes -  iffp-dst c!
  51.         runchar iffp-dst 1+ c!
  52.         iffp-dst# 2 - -> iffp-dst#
  53.         iffp-dst 2 + -> iffp-dst
  54.         false
  55.     THEN
  56. ;
  57.  
  58. \ Sorry this word is so cryptic. It was translated
  59. \ almost directly from 'C' and is quite tricky.
  60. : PACKROW ( src dst src# dst# -- dst' dst# error? )
  61. \ Define lots of local variables.
  62.     { src dst src# dst# | added# lastc rstart mode nbuf thisc error? -- }
  63.     dst# -> iffp-dst#  dst -> iffp-dst
  64.     0 -> added#  ( save for later calc )
  65.     src c@ -> lastc   0 -> mode
  66.     lastc pad c!  1 -> nbuf 0 -> rstart
  67.     src# 1
  68.     DO  src i + c@ dup -> thisc  ( get char )
  69.         pad nbuf + c! nbuf 1+ -> nbuf
  70.     mode
  71.         CASE
  72.         0 OF  nbuf 128 >
  73.             IF  nbuf 1- putdump
  74.                 IF iffp-dst iffp-dst# -1 return
  75.                 THEN
  76.                 thisc pad c!
  77.                 1 -> nbuf 0 -> rstart
  78.             ELSE
  79.                 thisc lastc =
  80.                 IF  nbuf rstart - 2 >
  81.                     IF  ( start a RUN )
  82.                         rstart 0>
  83.                         IF  rstart putdump
  84.                     IF iffp-dst iffp-dst# -1 return
  85.                     THEN
  86.                         THEN 1 -> mode
  87.                     ELSE
  88. \ At beginning of row?
  89.                         rstart 0=
  90.                         IF 1 -> mode
  91.                         THEN
  92.                     THEN
  93.                 ELSE nbuf 1- -> rstart  ( first of run )
  94.                 THEN
  95.             THEN
  96.             ENDOF
  97. \ Run length mode !!
  98.             1 OF
  99.             thisc lastc -  ( break run? )
  100.             nbuf rstart - 128 > OR
  101.             IF  nbuf 1- rstart -   lastc  putrun
  102.                 IF iffp-dst iffp-dst# -1 return THEN
  103.             thisc pad c!  ( start next dump )
  104.             1 -> nbuf 0 -> rstart
  105.             0 -> mode
  106.         THEN
  107.         ENDOF
  108.     ENDCASE
  109.     thisc -> lastc
  110.     LOOP
  111. \
  112. \ Finish dumping buffer.
  113.     mode
  114.     CASE
  115.         0 OF nbuf putdump IF iffp-dst 0 -1 return THEN
  116.             ENDOF
  117.         1 OF nbuf rstart -  lastc  putrun
  118.             IF iffp-dst iffp-dst# -1 return THEN
  119.         ENDOF
  120.     ENDCASE
  121.     iffp-dst iffp-dst# 0
  122. ;
  123.  
  124. \ Pack BITMAPs ----------------------------------------
  125. : PCOPYROW { src dst src_many dst_many -- dst' dst_many' error? }
  126.     src_many dst_many <
  127.     IF  src_many true
  128.     ELSE  src dst dst_many move  ( just move bytes !! )
  129.         src_many dst_many -  ( src_many' )
  130.         false
  131.     THEN
  132. ;
  133.  
  134. \ Compression = 1 is Run length encoded.
  135. \ Compression = 0 is uncompressed.
  136.  
  137. : BITMAP>BODY  { bmap bodyptr bsize compr | bresult -- bsize'|-1 }
  138.     compr 0= compr 1 = OR 0=
  139.     IF ." Illegal compression = " compr . 0 exit
  140.     THEN
  141.     bodyptr -> bresult
  142.     bmap ..@ bm_rows 0  ( for each row )
  143.     DO bmap ..@ bm_depth 0 ( for each plane )
  144.     DO
  145. \ next plane base
  146.         bmap .. bm_planes i cells + @ >rel ( src )
  147. \ offset to row
  148.         j bmap ..@ bm_bytesperrow * +
  149. \ place to put bytes
  150.             bodyptr  ( dst )
  151.         ( -- current-row body )
  152.         bmap ..@ bm_bytesperrow
  153.         bsize
  154.             compr 0=
  155.             IF pcopyrow
  156.             ELSE packrow
  157.             THEN  ( -- dst' dst_many error? )
  158.         IF .s 2drop
  159.             -1 -> bresult
  160.             leave
  161.         THEN
  162.         -> bsize
  163.         -> bodyptr
  164.     LOOP
  165.     bresult 0= IF leave THEN
  166.     LOOP
  167.     bresult -1 -
  168.     IF bodyptr bresult -  ( calculate size )
  169.     ELSE -1
  170.     THEN
  171. ;
  172.  
  173. : CTABLE>CMAP { ctable cmap #entries -- , pack }
  174. \ Convert Color Table data (2 bytes/RGB) to colorMap.
  175.     #entries 0
  176.     DO  ( -- ct cm )
  177.         ctable w@    ( next ctable value )
  178.         2 ctable + -> ctable
  179.     3 0
  180.     DO  dup
  181.         $ 0F and
  182.     4 ashift cmap 2 i - + c!
  183.         -4 ashift
  184.     LOOP drop
  185.     3 cmap + -> cmap
  186.     LOOP
  187. ;
  188.  
  189.